Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/misc/samples2/filefind.frm

Visual Basic Form | 1995-07-24 | 6.7 KB | 202 lines

VERSION 2.00
Begin Form Form1
   Caption         =   "File Find"
   ClientHeight    =   5820
   ClientLeft      =   1095
   ClientTop       =   1770
   ClientWidth     =   7365
   Height          =   6510
   Left            =   1035
   LinkTopic       =   "Form1"
   ScaleHeight     =   5820
   ScaleWidth      =   7365
   Top             =   1140
   Width           =   7485
   Begin CommandButton Command1
      Caption         =   "&Search"
      Default         =   -1  'True
      Height          =   480
      Left            =   5430
      TabIndex        =   4
      Top             =   765
      Width           =   1575
   End
   Begin TextBox Text1
      Height          =   330
      Left            =   165
      TabIndex        =   2
      Text            =   "Text1"
      Top             =   915
      Width           =   2280
   End
   Begin ListBox List1
      Height          =   3735
      Left            =   180
      TabIndex        =   1
      Top             =   1485
      Width           =   6885
   End
   Begin ListBox lstFastFiles
      Height          =   420
      Left            =   210
      TabIndex        =   0
      Top             =   210
      Visible         =   0   'False
      Width           =   1215
   End
   Begin Label Label2
      Caption         =   "Label2"
      Height          =   345
      Left            =   195
      TabIndex        =   5
      Top             =   5400
      Width           =   2595
   End
   Begin Label Label1
      Caption         =   "Label1"
      Height          =   870
      Left            =   180
      TabIndex        =   3
      Top             =   30
      Width           =   6915
   End
   Begin Menu mnuExit
      Caption         =   "Exit"
   End
'Used in the hard drive search routines
Const CHUNK = 10  ' Used for allocation of array space - how many elements at a time ?
Const FILECHUNK = 10
' Constants for API calls
Const WM_USER = &H400
Const LB_DIR = WM_USER + 14
Const SRCCOPY = &HCC0020
' Directory constants
Const ATTR_ARCHIVE = 32
Const ATTR_DIRECTORY = 16
Const ATTR_VOLUME = 8
Const ATTR_SYSTEM = 4
Const ATTR_HIDDEN = 2
Const ATTR_READONLY = 1
Const ATTR_NORMAL = 0
Dim Files() As FileInfo   ' Store the file info
Dim FileCount As Integer   ' How many files are in the array
Declare Function SendMessage Lib "user" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wp As Integer, lp As Any) As Long
Sub AddFile (Path$, Filename$)
'Add a file to the structure
    'Allocate more space if necessary
    If (FileCount Mod FILECHUNK) = 0 Then
        ReDim Preserve Files(FileCount + FILECHUNK)
    End If
    FileCount = FileCount + 1
    Files(FileCount).Path = Path$
    Files(FileCount).File = Filename$
End Sub
Sub Command1_Click ()
    SearchDrives
End Sub
Function FilesFound () As Integer
'Informs the caller how many files are in the structure
    FilesFound = FileCount
End Function
Sub Form_Load ()
    Me.Show
    msg$ = "Type in the file specification you want to search for.  "
    msg$ = msg$ + "Wildcards are permitted.  For example, to find all .VBX files, "
    msg$ = msg$ + "type ""*.vbx"".  NOTE:  You may get an out of memory error "
    msg$ = msg$ + "(or worse) if your search locates a large number of files "
    msg$ = msg$ + "(1200+)."
    label1 = msg$
    'Set default filespec
    Text1 = "*.vbx"
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1)
    Text1.SetFocus
    label2 = ""
End Sub
Sub Form_Unload (Cancel As Integer)
    End
End Sub
Sub ListFiles (Path$, Ext$)
' List all the files in a directory
Dim I As Integer, FileSpec As String
    FileSpec = Path$ + "\" + Ext$
    ' Tell Windows to fill the list box with the required file names
    ' The 7 represents  ATTR_SYSTEM + ATTR_HIDDEN + ATTR_READONLY + ATTR_NORMAL
    I = SendMessage(lstFastFiles.hWnd, LB_DIR, 7, ByVal FileSpec)
    For I = 0 To lstFastFiles.ListCount - 1
        Call AddFile(Path$, UCase$(lstFastFiles.List(I)))
    Next I
    lstFastFiles.Clear
End Sub
Sub ListSubDirs (Path$)
Dim Count, Directories() As String, I, DirName As String  ' Declare variables.
On Error GoTo errListSubDirs
    DoEvents
    'This is the filespec that will be searched for on all hard drives
    FileSpec$ = Text1
    Call ListFiles(Path$, FileSpec$)
    DirName = Dir(Path$ & "\", ATTR_DIRECTORY + ATTR_HIDDEN)' Get first directory name.
    'Iterate through PATH, caching all subdirectories in Directories()
    Do While (DirName <> "") And (Not ErrorOccured)
        If DirName <> "." And DirName <> ".." Then
            If (GetAttr(Path$ & "\" & DirName) And ATTR_DIRECTORY) = ATTR_DIRECTORY Then
                If (Count Mod CHUNK) = 0 Then
                    ReDim Preserve Directories(Count + CHUNK)    ' Resize the array.
                End If
                Count = Count + 1   ' Increment counter.
                Directories(Count) = DirName
            End If
        End If
        DirName = Dir$   ' Get another directory name.
    Loop
    ' Now recursively iterate through each cached subdirectory.
    I = 1
    While (I <= Count) And (Not ErrorOccured)
        Call ListSubDirs(Path$ & "\" & Directories(I))
        I = I + 1
    Wend
    Exit Sub
errListSubDirs:
    MsgBox "Error reading subdirectories", 48
    ErrorOccured = True
    Exit Sub
End Sub
Sub mnuExit_Click ()
    Unload Me
End Sub
Sub SearchDir ()
'Start the search
Dim a As String, I As Integer
    'Change to the root directory
    ChDir "\"
    a = CurDir$
    'Remove any backslash
    If Right$(a, 1) = "\" Then a = Left$(a, Len(a) - 1)
    Call ListSubDirs(a)  ' Start the recursive traverse of the tree
End Sub
Sub SearchDrives ()
On Error GoTo DriveError
    Screen.MousePointer = 11
    'Loop for every valid drive letter (C to Z)
    For I = 67 To 90
        label2 = "Searching drive " + Chr$(I) + ":"
        'When you try to change to a drive that doesn't exist, an error
        'occurs and the program jumps down to the DriveError label.
        ChDrive Chr$(I)
        SearchDir
    Next I
DriveError:

    label2 = ""
    Screen.MousePointer = 0   ' Reset the mouse pointer
    'This loop is where you would be likely to get an Out of Memory error if
    'your search found a large number of files.  I'm sure there is probably
    'a way to avoid it, but I didn't feel like messing with it.  After all,
    'this is only a sample.  :)
    For I = 1 To FileCount
        List1.AddItem UCase$(Files(I).Path) & "\" & UCase$(Files(I).File)
    Next I
    label2 = "Files Found:  " & Str$(FileCount)
    Exit Sub
End Sub